home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / wcl-21.lha / wcl-2.1 / src / compiler / common / globals.lisp < prev    next >
Lisp/Scheme  |  1992-09-10  |  12KB  |  514 lines
  1. ;;; (C) Copyright 1990-1992 by Wade L. Hennessey. All rights reserved.
  2.  
  3. (defvar *current-line* nil)
  4.  
  5. (defstruct code
  6.   tail?
  7.   mv-holder
  8.   (out-type t) 
  9.   (line *current-line*)
  10.   result-name)
  11.  
  12. (defstruct (c-code (:include code))
  13.   string)
  14.  
  15. (defstruct (seq (:include code)
  16.         (:copier nil))        ; don't trash CL COPY-SEQ
  17.   body)                    ; forms, control points and transfers
  18.  
  19. (defstruct (values-seq (:include seq))
  20.   values)
  21.  
  22. (defstruct (progn (:include seq)))
  23.  
  24. (defstruct (scope-seq (:include seq))    ; block and catch
  25.   control-point)
  26.  
  27. (defstruct (tag-seq (:include seq)) ; tagbody
  28.   control-points)
  29.  
  30. ;;; Multiple-inheritance would be nice here (static/dynamic, block/catch/tag)
  31. (defstruct (control-point (:include code))
  32.   name
  33.   parent                ; owning scope
  34.   refs                    ; list of nodes which ref us
  35.   id)
  36.  
  37. (defstruct (scope-control-point (:include control-point))
  38.   receive-var)
  39.  
  40. (defstruct (static-scope-control-point (:include scope-control-point))
  41.   c-name
  42.   convert?)                ; T if should convert to dynamic
  43.  
  44. (defstruct (dynamic-scope-control-point (:include scope-control-point))
  45.   tag-name)
  46.  
  47. (defstruct (dynamic-block-control-point
  48.          (:include dynamic-scope-control-point)))
  49.  
  50. (defstruct (catch-control-point (:include dynamic-scope-control-point)))
  51.  
  52. (defstruct (tag-control-point (:include control-point))
  53.   c-name)
  54.  
  55. (defstruct (static-tag-control-point (:include tag-control-point))
  56.   convert?)
  57.  
  58. (defstruct (dynamic-tag-control-point (:include tag-control-point))
  59.   tag-name)
  60.  
  61. (defstruct (control-transfer (:include code)) 
  62.   destination-point
  63.   unwind-count)
  64.  
  65. (defstruct (scope-control-transfer (:include control-transfer))
  66.   send-value)
  67.  
  68. (defstruct (tag-control-transfer (:include control-transfer)))
  69.  
  70. (defstruct (unwind-protect (:include code))
  71.   protected-form
  72.   cleanup-form)
  73.  
  74. (defstruct (spec-bind-seq (:include values-seq))
  75.   specials)
  76.  
  77. (defstruct (proc (:include seq))
  78.   var-info
  79.   name
  80.   c-name
  81.   max-tmp-var-count
  82.   vars-to-declare
  83.   funarg-refs                ; list of funarg refs
  84.   oe-var                ; null if we don't need it
  85.   start-label                ; only needed for tail rec removal
  86.   volatile)            
  87.  
  88. (defstruct (inner-proc (:include proc))
  89.   oe-refs
  90.   pass-on-oe?
  91.   parent-chain)
  92.  
  93. (defstruct (top-level-proc (:include proc))
  94.   oe-vars)                ; list of vars in oe
  95.  
  96. (defstruct var-info
  97.   requireds
  98.   optionals
  99.   keys
  100.   rest-var
  101.   restv-var
  102.   allow-other-keys?
  103.   auxes
  104.   hairy?
  105.   all-vars)
  106.  
  107. (defstruct basic-optional
  108.   var
  109.   init-form-expression          
  110.   init-form
  111.   supplied-var)
  112.  
  113. (defstruct (optional (:include basic-optional)))
  114.   
  115. (defstruct (key (:include basic-optional))
  116.   name)                    
  117.  
  118. (defstruct var                ; names functions and variables
  119.   name
  120.   c-name                ; init var or func name
  121.   declared-ok-to-ignore?
  122.   (definite-type t)
  123.   possible-types
  124.   num-refs
  125.   num-defs
  126.   extent                ; hey! bad name, change it....
  127.   dynamic-extent?            ; t when program declares it
  128.   innermost-proc)            ; only for indefinite
  129.  
  130. (defstruct (function-var (:include var)))
  131.  
  132. (defstruct (variable-var (:include var)))
  133.  
  134. (defstruct (var-op (:include code))
  135.   var
  136.   innermost-proc)
  137.  
  138. (defstruct (var-ref (:include var-op)))
  139.  
  140. (defstruct (var-def (:include var-op))
  141.   value)
  142.  
  143. (defstruct (constant (:include code))
  144.   data)
  145.  
  146. (defstruct (branch (:include code))
  147.   inline-test?
  148.   test)
  149.  
  150. (defstruct (if (:include branch))
  151.   then
  152.   else)
  153.  
  154. (defstruct (switch (:include branch))
  155.   keys
  156.   consequents
  157.   default)
  158.  
  159. (defstruct (inline-mv-call (:include values-seq))
  160.   new-holder
  161.   var-info)
  162.  
  163. (defstruct (mvalues (:include code))
  164.   args)
  165.  
  166. (defstruct (named-local (:include values-seq)) ; LET, FLET, LABELS
  167.   vars
  168.   letrec?)
  169.  
  170. (defstruct (function-call (:include code))
  171.   args
  172.   info
  173.   name)
  174.  
  175. (defstruct (named-call (:include function-call))
  176.   emit-as-goto?)
  177.  
  178. (defstruct (foreign-call (:include function-call)))
  179.  
  180. (defstruct (unnamed-call (:include function-call))
  181.   spread-args?
  182.   function-form)
  183.  
  184. (defstruct (primitive-call (:include function-call)))
  185.  
  186. (defstruct (c-struct-op (:include function-call))
  187.   struct-info
  188.   field)
  189.  
  190. (defstruct (c-struct-ref (:include c-struct-op))) ; args = (struct)
  191.  
  192. (defstruct (c-struct-def (:include c-struct-op))) ; args = (struct value)
  193.  
  194. (defvar *c-stream*)
  195. (defvar *win-stream*)
  196. (defvar *k-stream*)
  197. (defvar *package-stream*)
  198. (defvar *string-counter* -1)
  199. (defvar *const-labels*)
  200. (defvar *delay-proc-emit?* nil)
  201. (defvar *tmp-var-counter*)
  202. (defvar *name-id-counter*)
  203. (defvar *proc-chain* nil)
  204.  
  205. (defstruct foreign-symbol
  206.   name)
  207.  
  208. (defvar *undefined-functions* (make-hash-table :size 500 :test #'eq))
  209.  
  210. (defstruct function-info
  211.   name
  212.   ins
  213.   outs
  214.   in-types
  215.   out-types
  216.   meta-eval-arg-types
  217.   meta-eval-function)
  218.  
  219. (defstruct (function-and-method-info (:include function-info))
  220.   methods)
  221.  
  222. (defstruct (proc-info (:include function-and-method-info))
  223.   lambda-expr
  224.   source-file
  225.   inline?
  226.   defined?)
  227.  
  228. (defstruct (foreign-info (:include function-and-method-info))
  229.   foreign-name
  230.   in-type-objects
  231.   out-type-objects)
  232.  
  233. (defstruct (compiler-method (:include function-info))
  234.   new-function
  235.   transform)
  236.  
  237. (defstruct (primitive-info (:include function-info))
  238.   emitter)
  239.  
  240. (defstruct lex-env 
  241.   outermost-form
  242.   decls
  243.   variables
  244.   functions
  245.   blocks
  246.   tags)
  247.  
  248. (defvar *env*)
  249.  
  250. (defvar *compiler-macro-env* (make-macro-env))
  251.  
  252. (defvar *standard-type-specifier-symbols*
  253.   `(array               fixnum         package             simple-vector
  254.     atom                float          pathname            single-float
  255.     bignum              function       random-state        standard-char
  256.     bit                 hash-table     ratio               stream
  257.     bit-vector          integer        rational            string
  258.     character           keyword        readtable           string-char
  259.     common              list           sequence            symbol
  260.     compiled-function   long-float     short-float         t
  261.     complex             nil            simple-array        vector
  262.     cons                null           simple-bit-vector
  263.     double-float        member         simple-string))
  264.  
  265. (defvar *ok-foreign-declarations* nil
  266.     "List of foreign declarations which are ok to ignore")
  267.  
  268. (defstruct decls 
  269.   specials
  270.   types
  271.   ftypes
  272.   inlines
  273.   notinlines
  274.   ignores
  275.   dynamic-extents
  276.   optimizes)
  277.  
  278. ;;; HEY! Make subtypes of this, zap kind slot?
  279. (defstruct variable-info        ; HEY! call it GLOBAL-VARIABLE-INFO
  280.   name
  281.   kind
  282.   (type t)
  283.   constant-expr                ; used only by constants
  284.   ref-before-def?)
  285.  
  286. (defstruct library
  287.   name
  288.   directory
  289.   version
  290.   load-date
  291.   lisp-files
  292.   symbol-table
  293.   procedure-info
  294.   c-type-info
  295.   proclaims
  296.   init-thunk
  297.   other-object-files)
  298.  
  299. (defvar *primary-function-info* nil)
  300.  
  301. (defvar *new-function-info* nil)
  302.  
  303. (defvar *variable-info* (make-hash-table :size 300))
  304.  
  305. ;; HEY! These are also defined in the library. Merge...
  306. (defvar *structure-info* (make-hash-table :size 100))
  307.  
  308. (defvar *c-named-types* (make-hash-table :size 100))
  309.  
  310. (defvar *referenced-c-info* nil)
  311.  
  312. (defvar *external-procs* nil)
  313.  
  314. (defconstant argc-var-name "argc")
  315.  
  316. (defvar *emitting-proc?* nil)
  317.  
  318. (defvar *inner-procs*)
  319.  
  320. (defvar *analysis-errors*)
  321.  
  322. (defvar *node-id*)
  323.  
  324. (defvar *dynamic-control-points*)
  325.  
  326. (defvar *break-on-compiler-warn?* nil)
  327.   
  328. (defvar *keyword-package* (find-package "KEYWORD"))
  329.  
  330. (defvar *compile-file-pathname*)
  331.  
  332. (defvar *compile-verbose* t)
  333.  
  334. (defvar *compile-print* nil)
  335.  
  336. (defvar *libraries* (make-hash-table :test #'equal))
  337.  
  338. (defvar *compiler-initialized?* nil)
  339.  
  340. (defvar *compiler-package*
  341.   #+NATIVE-WCL *lisp-package*
  342.   #-NATIVE-WCL (find-package "W"))
  343.  
  344. (defvar *line-number-readtable*
  345.   #+NATIVE-WCL (make-line-number-readtable)
  346.   #-NATIVE-WCL *readtable*)
  347.  
  348. (defvar *source-table* nil)
  349.  
  350. (defvar *link-start-time*)
  351.  
  352. (defvar *char-conversions*
  353.   #("_00" "_01" "_02" "_03" "_04" "_05" "_06" "_07" "_08" "_09" "_0A"
  354.     "_0B" "_0C" "_0D" "_0E" "_0F" "_10" "_11" "_12" "_13" "_14" "_15"
  355.     "_16" "_17" "_18" "_19" "_1A" "_1B" "_1C" "_1D" "_1E" "_1F" "_20"
  356.     "_21" "_22" "_23" "_24" "_25" "_26" "_27" "_28" "_29" "_2A" "_2B"
  357.     "_2C" "_2D" "_2E" "_2F" "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"
  358.     "_3A" "_3B" "_3C" "_3D" "_3E" "_3F" "_40" "A" "B" "C" "D" "E" "F"
  359.     "G" "H" "I" "J" "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T" "U" "V" "W"
  360.     "X" "Y" "Z" "_5B" "_5C" "_5D" "_5E" "_5F" "_60" "a" "b" "c" "d" "e" "f"
  361.     "g" "h" "i" "j" "k" "l" "m" "n" "o" "p" "q" "r" "s" "t" "u" "v" "w" "x"
  362.     "y" "z" "_7B" "_7C" "_7D" "_7E" "_7F"))
  363.  
  364. (defstruct (application-package
  365.          (:print-function
  366.           (lambda (x stream depth)
  367.         (declare (ignore depth))
  368.         (format stream "#<APPLICATION PACKAGE: ~A>"
  369.             (application-package-host-package x)))))
  370.   ;; (print-unreadable-object (x stream :type t :identity t)
  371.   ;;   (format stream "~A" (application-package-host-package x)))
  372.   host-package
  373.   symbol-array-c-name
  374.   symbols)
  375.  
  376. (defstruct application-symbol
  377.   sym
  378.   used-as-data?
  379.   value
  380.   plist        
  381.   (c-name (lisp->c-symbol-name sym))
  382.   function
  383.   (hash-code (sxhash-w sym))
  384.   (flags 0))
  385.  
  386. (defvar *tmp-file-counter* 0)
  387.  
  388. (defvar *default-libraries* '(:cl))
  389.  
  390. (defvar *pic?* nil)
  391.  
  392. (defvar *emit-symbol-data-function* nil)
  393.  
  394. (defstruct c-type-info
  395.   name
  396.   c-type
  397.   convert-to-lisp
  398.   convert-to-c
  399.   constant-to-c)
  400.  
  401. (defstruct c-array-info            ; pointer = array in C
  402.   element-type
  403.   dimensions)
  404.  
  405. (defstruct c-struct-info
  406.   name
  407.   slots)
  408.  
  409. (defstruct c-struct-slot
  410.   name
  411.   (c-name (lisp->c-field-name name))
  412.   type)
  413.  
  414. (defvar c-type-int8
  415.   (make-c-type-info :name 'int8
  416.             :c-type "char"
  417.             :convert-to-lisp "INT_TO_FX"
  418.             :convert-to-c "FX_TO_INT"
  419.             :constant-to-c #'identity))
  420.  
  421. (defvar c-type-uint8
  422.   (make-c-type-info :name 'uint8
  423.             :c-type "unsigned char"
  424.             :convert-to-lisp "INT_TO_FX"
  425.             :convert-to-c "FX_TO_INT"
  426.             :constant-to-c #'identity))
  427.  
  428. (defvar c-type-int16
  429.   (make-c-type-info :name 'int16
  430.             :c-type "short"
  431.             :convert-to-lisp "INT_TO_FX"
  432.             :convert-to-c "FX_TO_INT"
  433.             :constant-to-c #'identity))
  434.  
  435. (defvar c-type-uint16
  436.   (make-c-type-info :name 'uint16
  437.             :c-type "unsigned short"
  438.             :convert-to-lisp "INT_TO_FX" 
  439.             :convert-to-c "FX_TO_INT"
  440.             :constant-to-c #'identity))
  441.  
  442.  
  443. (defvar c-type-int31
  444.   (make-c-type-info :name 'int31
  445.             :c-type "int"
  446.             :convert-to-lisp "INT_TO_FX"
  447.             :convert-to-c  "FX_TO_INT"
  448.             :constant-to-c #'identity))
  449.             
  450.  
  451. (defvar c-type-uint31
  452.   (make-c-type-info :name 'uint31
  453.             :c-type "unsigned long"
  454.             :convert-to-lisp "INT_TO_FX"
  455.             :convert-to-c "FX_TO_INT"
  456.             :constant-to-c #'identity))
  457.  
  458.  
  459. (defvar c-type-int32
  460.   (make-c-type-info :name 'int32
  461.             :c-type "int"
  462.             :convert-to-lisp "INT32_TO_INTEGER"
  463.             :convert-to-c "INTEGER_TO_INT32"
  464.             :constant-to-c #'identity))
  465.  
  466.  
  467. (defvar c-type-uint32
  468.   (make-c-type-info :name 'uint32
  469.             :c-type "unsigned long"
  470.             :convert-to-lisp "UINT32_TO_INTEGER"
  471.             :convert-to-c "INTEGER_TO_UINT32"
  472.             :constant-to-c #'identity))
  473.  
  474. (defvar c-type-char
  475.   (make-c-type-info :name 'char
  476.             :c-type "char"
  477.             :convert-to-lisp "NEW_CHAR"
  478.             :convert-to-c "RAW_CHAR"))
  479.  
  480. (defvar c-type-double
  481.   (make-c-type-info :name 'double
  482.             :c-type "double"
  483.             :convert-to-lisp "NEW_FLOAT"
  484.             :convert-to-c "RAW_FLOAT"))
  485.  
  486. (defvar c-type-lptr
  487.   (make-c-type-info :name 'lptr
  488.             :c-type "LP"
  489.             :convert-to-lisp ""
  490.             :convert-to-c ""))
  491.  
  492. (defvar c-type-fptr
  493.   (make-c-type-info :name 'fptr
  494.             :c-type ""
  495.             :convert-to-lisp "NEW_FPTR"
  496.             :convert-to-c "RAW_FPTR"))
  497.  
  498. (defvar c-type-void
  499.   (make-c-type-info :name 'void
  500.             :c-type "void"
  501.             :convert-to-lisp ""
  502.             :convert-to-c ""))
  503.  
  504. ;;; This is wierd, but primitives need it
  505. (defvar c-type-if-test
  506.   (make-c-type-info :name 'if-test
  507.             :c-type "if-test"
  508.             :convert-to-lisp ""
  509.             :convert-to-c ""))
  510.  
  511. (defvar c-type-char-string
  512.   (make-c-array-info :element-type c-type-char
  513.              :dimensions nil))
  514.